home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / merror.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  13.2 KB  |  409 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12.  
  13.  
  14. (macsyma-module merror)
  15.  
  16. ;;; Macsyma error signalling. 
  17. ;;; 2:08pm  Tuesday, 30 June 1981 George Carrette.
  18.  
  19. (defvar DEBUG T "Enter the lisp on an error debugger if this is true")
  20.  
  21. (DEFMVAR $ERROR '((MLIST SIMP) |&No error.|)
  22.   "During an MAXIMA-ERROR break this is bound to a list
  23.   of the arguments to the call to MAXIMA-ERROR, with the message
  24.   text in a compact format.")
  25.  
  26. (DEFMVAR $ERRORMSG 'T
  27.   "If FALSE then NO MAXIMA-ERROR message is printed!")
  28.  
  29. (DEFMFUN $ERROR (&REST L)
  30.   "Signals a Macsyma user error."
  31.   (apply #'merror (fstringc L)))
  32.  
  33. (DEFMVAR $ERROR_SIZE 10.
  34.   "Expressions greater in SOME size measure over this value
  35.   are replaced by symbols {ERREXP1, ERREXP2,...} in the MAXIMA-ERROR
  36.   display, the symbols being set to the expressions, so that one can
  37.   look at them with expression editing tools. The default value of
  38.   this variable may be determined by factors of terminal speed and type.")
  39.  
  40. ;(declare-top (FIXNUM (ERROR-SIZE NIL)))
  41.  
  42. (DEFUN ERROR-SIZE (EXP)
  43.   (IF (ATOM EXP) 0
  44.       (DO ((L (CDR EXP) (CDR L))
  45.        (N 1 (f1+ (f+ N (ERROR-SIZE (CAR L))))))
  46.       ((OR (NULL L)
  47.            ;; no need to go any further, and this will save us
  48.            ;; from circular structures. (Which they display
  49.            ;; package would have a hell of a time with too.)
  50.            (> N $ERROR_SIZE))
  51.        N)
  52.     (DECLARE (FIXNUM N)))))
  53.  
  54. ;;; Problem: Most macsyma users do not take advantage of break-points
  55. ;;; for debugging. Therefore they need to have the error variables
  56. ;;; SET (as the old ERREXP was), and not PROGV bound. The problem with
  57. ;;; this is that recursive errors will bash the old value of the
  58. ;;; error variables. However, since we do bind the value of the
  59. ;;; variable $ERROR, calling the function $ERRORMSG will always
  60. ;;; set things back. It would be better to bind these variables,
  61. ;;; for, amoung other things, then the values could get garbage 
  62. ;;; collected.
  63.  
  64. ;Make up your mind.  The first definition here, commented out, is the
  65. ; original in the source.  I guess the binding didn't make it, because
  66. ; the second is from the 302 fix file F302. --gsb
  67. ;(DEFMFUN MERROR (STRING &REST L)
  68. ;  (SETQ STRING (CHECK-OUT-OF-CORE-STRING STRING))
  69. ;  (LET (($ERROR `((MLIST) ,STRING ,@L)))
  70. ;    (AND $ERRORMSG ($ERRORMSG))
  71. ;    (ERROR #+(OR LISPM NIL) STRING)))
  72. ;#-cl
  73. ;(DEFMFUN MERROR (STRING &REST L)
  74. ;  (SETQ STRING (CHECK-OUT-OF-CORE-STRING STRING))
  75. ;  (SETQ $ERROR `((MLIST) ,STRING ,@L))
  76. ;  (AND $ERRORMSG ($ERRORMSG))
  77. ;  (MAXIMA-ERROR #+(OR CL NIL) STRING))
  78.  
  79.  
  80. #+(and cl (not lispm))
  81. (DEFUN MERROR (SSTRING &REST L)
  82.      (declare (special state-pdl errcatch debug))
  83.      (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
  84.      (AND $ERRORMSG ($ERRORMSG))
  85.      (cond (debug
  86.         (let ((dispflag t) ret)
  87.           (declare (special $help dispflag))
  88.           (format t " -- an error.  Entering the Maxima Debugger dbm")
  89.           (progn
  90.             (setq ret ;;;(errbreak nil)
  91.               (break-dbm-loop nil)
  92.               )
  93.             (cond ((eql ret :resume)
  94.                (break-quit)))
  95.             
  96.             #+previous
  97.             (cond ((and (eql ret 'exit)
  98.                 (member 'macsyma-break state-pdl))
  99.                (throw 'macsyma-break t))
  100.               (t  (throw 'macsyma-quit t)
  101.                   )))
  102.  
  103.           
  104.           
  105.           )
  106.         )
  107.            (errcatch  (error " -- an error: macsyma error"))
  108.            (t
  109.         (fresh-line *standard-output*)
  110.         ($backtrace 3)
  111.         (format t "~& -- an error.  Quitting.  To debug this try DEBUGMODE(TRUE);)~%")
  112.         (throw 'macsyma-quit t )
  113.         ;(if errcatch (error "macsyma error"))
  114.         )))
  115.  
  116.  
  117.  
  118. #+(or CL NIL)
  119. ;;; for debugging.  Therefore they need to have the error variables
  120. ;;; SET (as the old ERREXP was), and not PROGV bound.  The problem with
  121. ;;; this is that recursive errors will bash the old value of the error 
  122. ;;; variables.  It would be better to bind these variables, for, among 
  123. ;;; other things, then the values could get garbage collected.
  124.  
  125. ;; Define the MACSYMA-ERROR condition.
  126.  
  127. #+lispm
  128. (eval-when (compile load)
  129. (DEFFLAVOR MACSYMA-ERROR (MFORMAT-STRING #-ti(format-args nil)) (global:ERROR)
  130.   :INITABLE-INSTANCE-VARIABLES
  131.   :gettable-instance-variables)
  132. (DEFFLAVOR MACSYMA-DEBUGGER (MFORMAT-STRING) (global:ERROR)
  133.   :INITABLE-INSTANCE-VARIABLES)            
  134.  
  135. )
  136.  
  137.  
  138. ;sample:
  139. ;(defun h (he)
  140. ;  (merror "hi there ~:M and ~:M" he he))
  141.  
  142. #+lispm
  143. (progn 
  144. (DEFMETHOD (MACSYMA-ERROR :REPORT) (STREAM)
  145.     (apply 'format stream mformat-string #-ti format-args #+ti eh:format-args))
  146.  
  147.  
  148.  
  149. (COMPILE-FLAVOR-METHODS MACSYMA-ERROR)
  150.  
  151. ;;; I'm not sure that this is the right way to do this. We can always flush this when
  152. ;;; enter-macsyma-debugger does the right thing.
  153.  
  154.  
  155.  
  156. (DEFMETHOD (MACSYMA-DEBUGGER :REPORT) (STREAM)
  157.   stream ;ignore
  158. ;  (aformat STREAM MFORMAT-STRING)
  159.  )
  160.  
  161. ;;Don't want to call the following since it will then the function displayed
  162. (DEFUN ENTER-MACSYMA-DEBUGGER ()
  163.  (signal 'MACSYMA-DEBUGGER ':MFORMAT-STRING "Entering Lisp Debugger")
  164.  
  165.   )
  166.  
  167.  
  168. (DEFPROP MERROR T :ERROR-REPORTER)
  169.  
  170. (DEFPROP enter-macsyma-debugger T :ERROR-REPORTER)
  171. )
  172.  
  173.  
  174.  
  175. #+ti
  176. (DEFMFUN MERROR (SSTRING &REST L)
  177.      (SETQ SsTRING (CHECK-OUT-OF-CORE-STRING sSTRING))
  178.      (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
  179.      (AND $ERRORMSG ($ERRORMSG))
  180.      (IF DEBUG
  181.                (ENTER-MACSYMA-DEBUGGER)  
  182. ;         (signal 'MACSYMA-ERROR ':MFORMAT-STRING
  183. ;             sstring            ;(zl:format nil SsTRING)
  184. ;             :format-args  (copy-rest-arg l))
  185.              ;;the following should work..but int rel1.0
  186.          ;(signal 'macsyma-error  :mformat-string  SsTRING  :format-args l )
  187.          (signal-condition (make-condition 'macsyma-error  :mformat-string  SsTRING  :format-args l ))))
  188.         
  189.  
  190. #+(and LISPM  (not ti))
  191. (DEFMFUN MERROR (SSTRING &REST L)
  192.   (SETQ SsTRING (CHECK-OUT-OF-CORE-STRING sSTRING))
  193.   (SETQ $ERROR `((MLIST) ,SsTRING ,@ (COPY-rest-arg L)))
  194.   (AND $ERRORMSG ($ERRORMSG))
  195.   #+LISPM (IF DEBUG
  196.                 (ENTER-MACSYMA-DEBUGGER)  
  197.             (signal 'MACSYMA-ERROR ':MFORMAT-STRING
  198.               #+(and cl symbolics)
  199.               sstring ;(zl:format nil SsTRING)
  200.               #-(or cl symbolics) sstring
  201.               :format-args  (copy-rest-arg l)
  202.                )
  203.           )
  204.   #+lispm
  205.   (signal 'macsyma-error  :mformat-string  SsTRING  :format-args l )
  206.   #+ nil (maxima-error sstring)
  207.   #-(OR LISPM NIL) (MAXIMA-ERROR))
  208.  
  209. (DEFMVAR $ERROR_SYMS '((MLIST) $ERREXP1 $ERREXP2 $ERREXP3)
  210.   "Symbols to bind the too-large MAXIMA-ERROR expresssions to")
  211.  
  212. (DEFUN-prop ($ERROR_SYMS ASSIGN) (VAR VAL)
  213.   (IF (NOT (AND ($LISTP VAL)
  214.         (DO ((L (CDR VAL) (CDR L)))
  215.             ((NULL L) (RETURN T))
  216.           (IF (NOT (SYMBOLP (CAR L))) (RETURN NIL)))))
  217.       (MERROR "The variable ~M being set to ~M which is not a list of symbols."
  218.           VAR VAL)))
  219.  
  220. (DEFUN PROCESS-ERROR-ARGL (L)
  221.   ;; This returns things so that we could set or bind.
  222.   (DO ((ERROR-SYMBOLS NIL)
  223.        (ERROR-VALUES NIL)
  224.        (NEW-ARGL NIL)
  225.        (SYMBOL-NUMBER 0))
  226.       ((NULL L)
  227.        (LIST (NREVERSE ERROR-SYMBOLS)
  228.          (NREVERSE ERROR-VALUES)
  229.          (NREVERSE NEW-ARGL)))
  230.     (LET ((FORM (POP L)))
  231.       (COND ((> (ERROR-SIZE FORM) $ERROR_SIZE)
  232.          (SETQ SYMBOL-NUMBER (f1+ SYMBOL-NUMBER))
  233.          (LET ((SYM (NTHCDR SYMBOL-NUMBER $ERROR_SYMS)))
  234.            (COND (SYM
  235.               (SETQ SYM (CAR SYM)))
  236.              ('ELSE
  237.               (SETQ SYM (CONCAT '$ERREXP SYMBOL-NUMBER))
  238.               (SETQ $ERROR_SYMS (APPEND $ERROR_SYMS (LIST SYM)))))
  239.            (PUSH SYM ERROR-SYMBOLS)
  240.            (PUSH FORM ERROR-VALUES)
  241.            (PUSH SYM NEW-ARGL)))
  242.         ('ELSE
  243.          (PUSH FORM NEW-ARGL))))))
  244.  
  245. (DEFMFUN $ERRORMSG ()
  246.   "ERRORMSG() redisplays the MAXIMA-ERROR message while in an MAXIMA-ERROR break."
  247.   ;; Don't optimize out call to PROCESS-ERROR-ARGL in case of
  248.   ;; multiple calls to $ERRORMSG, because the user may have changed
  249.   ;; the values of the special variables controling its behavior.
  250.   ;; The real expense here is when MFORMAT calls the DISPLA package.
  251.   (LET ((THE-JIG (PROCESS-ERROR-ARGL (CDDR $ERROR))))
  252.     (MAPC #'SET (CAR THE-JIG) (CADR THE-JIG))
  253.     (fresh-line)
  254.     (LET ((ERRSET NIL))
  255.       (IF (NULL (ERRSET
  256.          (APPLY #'MFORMAT nil
  257.             (CADR $ERROR) (CADDR THE-JIG))))
  258.       (MTELL "~%** error while printing ERROR message **~%~A~%"
  259.          (CADR $ERROR)
  260.          )))
  261.     (fresh-line)
  262.     )
  263.   '$DONE)
  264.  
  265. (DEFMFUN READ-ONLY-ASSIGN (VAR VAL)
  266.   (IF MUNBINDP
  267.       'MUNBINDP
  268.       (MERROR "Attempting to assign read-only variable ~:M the value:~%~M"
  269.           VAR VAL)))
  270.  
  271.  
  272. (DEFPROP $ERROR READ-ONLY-ASSIGN  ASSIGN)
  273.  
  274.  
  275. ;; THIS THROWS TO  (CATCH 'RATERR ...), WHEN A PROGRAM ANTICIPATES
  276. ;; AN ERROR (E.G. ZERO-DIVIDE) BY SETTING UP A CATCH  AND SETTING
  277. ;; ERRRJFFLAG TO T.  Someday this will be replaced with SIGNAL.
  278. ;; Such skill with procedure names!  I'd love to see how he'd do with
  279. ;; city streets.
  280.  
  281. ;;; N.B. I think the above comment is by CWH, this function used
  282. ;;; to be in RAT;RAT3A. Its not a bad try really, one of the better
  283. ;;; in macsyma. Once all functions of this type are rounded up
  284. ;;; I'll see about implementing signaling. -GJC
  285.  
  286. (DEFMFUN ERRRJF N
  287.   (IF ERRRJFFLAG (THROW 'RATERR NIL) (APPLY #'MERROR (LISTIFY N))))
  288.  
  289. ;;; The user-error function is called on |&foo| "strings" and expressions.
  290. ;;; Cons up a format string so that $ERROR can be bound.
  291. ;;; This might also be done at code translation time.
  292. ;;; This is a bit crude.
  293.  
  294. (defmfun fstringc (L)
  295.   (do ((sl nil) (s) (sb)
  296.         (se nil))
  297.       ((null l)
  298.        (setq sl (maknam sl))
  299.        #+PDP10
  300.        (putprop sl t '+INTERNAL-STRING-MARKER)
  301.        (cons sl (nreverse se)))
  302.     (setq s (pop l))
  303.     (cond ((and (symbolp s) (char= (getcharn s 1) #\&))
  304.        (setq sb (mapcan #'(lambda (x)
  305.                 (if (char= x #\~)
  306.                     (list x x)
  307.                     (list x)))
  308.                 (cdr (exploden s)))))
  309.       (t
  310.        (push s se)
  311.        (setq sb (list #\~ #\M))))
  312.     (setq sl (nconc sl sb (if (null l) nil (list #\SPACE))))))
  313.  
  314.  
  315.  
  316. #+PDP10
  317. (PROGN 'COMPILE
  318.        ;; Fun and games with the pdp-10. The calling sequence for
  319.        ;; subr, (arguments passed through registers), is much smaller
  320.        ;; than that for lsubrs. If we really where going to do a lot
  321.        ;; of this hackery then we would define some kind of macro
  322.        ;; for it.
  323.        (LET ((X (GETL 'MERROR '(EXPR LSUBR))))
  324.      (REMPROP '*MERROR (CAR X))
  325.      (PUTPROP '*MERROR (CADR X) (CAR X)))
  326.        (DECLARE (*LEXPR *MERROR))
  327.        (DEFMFUN *MERROR-1 (A)         (*MERROR A))
  328.        (DEFMFUN *MERROR-2 (A B)       (*MERROR A B))
  329.        (DEFMFUN *MERROR-3 (A B C)     (*MERROR A B C))
  330.        (DEFMFUN *MERROR-4 (A B C D)   (*MERROR A B C D))
  331.        (DEFMFUN *MERROR-5 (A B C D E) (*MERROR A B C D E))
  332.  
  333.  
  334.        (LET ((X (GETL 'ERRRJF '(EXPR LSUBR))))
  335.      (REMPROP '*ERRRJF (CAR X))
  336.      (PUTPROP '*ERRRJF (CADR X) (CAR X)))
  337.        (DECLARE (*LEXPR *ERRRJF))
  338.        (DEFMFUN *ERRRJF-1 (A) (*ERRRJF A))
  339.  
  340.        )
  341. #+Maclisp
  342. (progn 'compile
  343. (defun m-wna-eh (((f . actual-args) args-info))
  344.   ;; generate a nice user-readable message about this lisp error.
  345.   ;; F may be a symbol or a lambda expression.
  346.   ;; args-info may be nil, an args-info form, or a formal argument list.
  347.   (merror "~M ~A to function ~A"
  348.       `((mlist) ,@actual-args)
  349.       ;; get the error messages passed as first arg to lisp ERROR.
  350.       (caaddr (errframe ()))
  351.       (if (symbolp f)
  352.           (if (or (equal (args f) args-info)
  353.               (symbolp args-info))
  354.           f
  355.           `((,f),@args-info))
  356.           `((lambda)((mlist),@(cadr f))))))
  357.  
  358. (defun m-wta-eh ((object))
  359.   (merror "~A: ~A" (caaddr (errframe ())) object))
  360.  
  361. (defun m-ubv-eh ((variable))
  362.   (merror "Unbound variable: ~A" variable))
  363.  
  364. ;; TRANSL generates regular LISP function calls for functions which
  365. ;; are lisp defined at translation time, and in compiled code.
  366. ;; MEXPRs can be handled by the UUF (Undefined User Function) handler.
  367.  
  368. (DEFVAR UUF-FEXPR-ALIST ())
  369. #+lispm
  370. (DEFPROP ENTER-MACSYMA-DEBUGGER T :ERROR-REPORTER)
  371.  
  372. (DEFUN UUF-HANDLER (X)
  373.   (LET ((FUNP (OR (MGETL (CAR X) '(MEXPR MMACRO))
  374.           (GETL (CAR X) '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S)))))
  375.     (CASE (CAR FUNP)
  376.       ((MEXPR)
  377.        ;; The return value of the UUF-HANDLER is put back into
  378.        ;; the "CAR EVALUATION LOOP" of the S-EXP. It is evaluated,
  379.        ;; checked for "functionality" and applied if a function,
  380.        ;; otherwise it is evaluated again, unless it's atomic,
  381.        ;; in which case it will call the UNDF-FNCTN handler again,
  382.        ;; unless (STATUS PUNT) is NIL in which case it is
  383.        ;; evaluated (I think). One might honestly ask
  384.        ;; why the maclisp evaluator behaves like this. -GJC
  385.        `((QUOTE (LAMBDA *N*
  386.           (MAPPLY ',(CAR X) (LISTIFY *N*) ',(CAR X) (LISTIFY *N*))))))
  387.       ((MMACRO TRANSLATED-MMACRO)
  388.        (MERROR
  389.     "Call to a macro '~:@M' which was undefined during translation."
  390.     (CAR X)))
  391.       ((MFEXPR* MFEXPR*S)
  392.        ;; An call in old translated code to what was a FEXPR.
  393.        (LET ((CELL (ASSQ (CAR X) UUF-FEXPR-ALIST)))
  394.      (OR CELL
  395.          (LET ((NAME (GENSYM)))
  396.            (PUTPROP NAME
  397.             `(LAMBDA (,NAME) (MEVAL (CONS '(,(CAR X)) ,NAME)))
  398.             'FEXPR)
  399.            (SETQ CELL (LIST (CAR X) NAME))
  400.            (PUSH CELL UUF-FEXPR-ALIST)))
  401.      (CDR CELL)))
  402.       (T
  403.        (MERROR "Call to an undefined function '~A' at Lisp level."
  404.            (CAR X))))))
  405. )
  406.  
  407. nil
  408.  
  409.